home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tix4.1 / fs.tcl < prev    next >
Encoding:
Text File  |  1998-12-04  |  11.4 KB  |  645 lines
  1. # tixAssert --
  2. #
  3. #    Debugging routine. Evaluates the test script in the context of the
  4. #    caller. The test script is responsible for generating the error.
  5. #    
  6. proc tixAssert {script} {
  7.     uplevel $script
  8. }
  9.  
  10. proc tixAssertNorm {path} {
  11.     if ![tixFSIsNorm $path] {
  12.     error "\"$path\" is not a normalized path"
  13.     }
  14. }
  15.  
  16. proc tixAssertVPath {vpath} {
  17.     if ![tixFSIsVPath $vpath] {
  18.     error "\"$vpath\" is not a VPATH"
  19.     }
  20. }
  21.  
  22. # tixFSAbsPath --
  23. #
  24. #    Converts $path into an normalized absolute path
  25. #
  26. proc tixFSAbsPath {path} {
  27.     return [lindex [tixFSNorm [tixFSVPWD] $path] 0]
  28. }
  29.  
  30. # tixFSVPWD --
  31. #
  32. #    Returns the VPATH of the current directory.
  33. #
  34. proc tixFSVPWD {} {
  35.     return [tixFSVPath [tixFSPWD]]
  36. }
  37.  
  38. if {![info exists tcl_platform] || $tcl_platform(platform) == "unix"} {
  39.  
  40. # tixFSPWD --
  41. #
  42. #    Return the current directory
  43. #
  44. proc tixFSPWD {} {
  45.     return [pwd]
  46. }
  47.  
  48. # tixFSDisplayName --
  49. #
  50. #    Returns the name of a normalized path which is usually displayed by
  51. #    the OS
  52. #
  53. proc tixFSDisplayName {normpath} {
  54.     tixAssert {
  55.     tixAssertNorm $normpath
  56.     }
  57.     return $normpath
  58. }
  59.  
  60. proc tixFSIsAbsPath {path} {
  61.     return [tixStrEq [string index $path 0] /]
  62. }
  63.  
  64. # tixFSIsNorm_os --
  65. #
  66. #    Returns true iff this pathname is normalized, in the OS native name
  67. #    format
  68. #
  69. proc tixFSIsNorm_os {path} {
  70.     return [tixFSIsNorm $path]
  71. }
  72.  
  73. proc tixFSIsNorm {path} {
  74.     if [tixStrEq $path /] {
  75.     return 1
  76.     }
  77.  
  78.     # relative path
  79.     #
  80.     if ![regexp {^/} $path] {
  81.     return 0
  82.     }
  83.  
  84.     if [regexp {/[.]$} $path] {
  85.     return 0
  86.     }
  87.     if [regexp {/[.][.]$} $path] {
  88.     return 0
  89.     }
  90.     if [regexp {/[.]/} $path] {
  91.     return 0
  92.     }
  93.     if [regexp {/[.][.]/} $path] {
  94.     return 0
  95.     }
  96.     if [tixStrEq $path .] {
  97.     return 0
  98.     }
  99.     if [tixStrEq $path ..] {
  100.     return 0
  101.     }
  102.  
  103.     # Tilde
  104.     #
  105.     if [regexp {^~} $path] {
  106.     return 0
  107.     }
  108.  
  109.     # Double slashes
  110.     #
  111.     if [regexp {//} $path] {
  112.     return 0
  113.     }
  114.  
  115.     # Trailing slashes
  116.     #
  117.     if [regexp {/$} $path] {
  118.     return 0
  119.     }
  120.  
  121.     return 1
  122. }
  123.  
  124. # tixFSIsValid --
  125. #
  126. #    Checks whether a native pathname contains invalid characters.
  127. #
  128. proc tixFSIsValid {path} {
  129.     return 1
  130. }
  131.  
  132. proc tixFSIsVPath {vpath} {
  133.     return [tixFSIsNorm $vpath]
  134. }
  135.  
  136. # tixFSVPath --
  137. #
  138. #    Converts a native pathname to its VPATH
  139. #
  140. proc tixFSVPath {path} {
  141.     tixAssert {
  142.     tixAssertNorm $path
  143.     }
  144.     return $path
  145. }
  146.  
  147. # tixFSPath --
  148. #
  149. #    Converts a vpath to a native pathname
  150. proc tixFSPath {vpath} {
  151.     tixAssert {
  152.     tixAssertVPath $vpath
  153.     }
  154.     return $vpath
  155. }
  156.  
  157. # tixFSTildeSubst -- [Unix only]
  158. #
  159. #    Substitutes any leading tilde characters if possible. No error is
  160. #    generated if the user doesn't exist.
  161. #
  162. proc tixFSTildeSubst {text} {
  163.     if [tixStrEq [string index $text 0] ~] {
  164.     # The following will report if the user doesn't exist
  165.     if [catch {
  166.         file isdir $text
  167.     }] {
  168.         return ./$text
  169.     }
  170.     return [tixFile tilde $text]
  171.     } else {
  172.     return $text
  173.     }
  174. }
  175.  
  176. # tixFSNorm --
  177. #
  178. #    Interprets the user's input and return file information about this
  179. #    input.
  180. #
  181. # Arguments:
  182. #    See documentation (docs/Files.txt)
  183. #
  184. proc tixFSNorm {context text {defFile ""} {flagsVar ""} {errorMsgVar ""}} {
  185.     tixAssert {
  186.     tixAssertVPath $context
  187.     }
  188.  
  189.     if ![tixStrEq $errorMsgVar ""] {
  190.     upvar $errorMsgVar errorMsg
  191.     }
  192.     if ![tixStrEq $flagsVar ""] {
  193.     upvar $flagsVar flags
  194.     }
  195.  
  196.     set hasDirSuffix [regexp {/$} $text]
  197.     set text [tixFSTildeSubst $text]
  198.     set text [_tixJoin $context $text]
  199.  
  200.     if {$hasDirSuffix || [file isdir $text]} {
  201.     set dir $text
  202.     set tail $defFile
  203.     } else {
  204.     set dir [file dirname $text]
  205.     set tail [file tail $text]
  206.     }
  207.  
  208.     set norm $dir/$tail
  209.     regsub -all /+ $norm / norm
  210.     if ![tixStrEq $norm /] {
  211.     regsub {/$} $norm "" norm
  212.     }
  213.  
  214.     if ![info exists flag(noPattern)] {
  215.     set isPat 0
  216.     foreach char [split $tail ""] {
  217.         if {$char == "*" || $char == "?"} {
  218.         set isPat 1
  219.         break
  220.         }
  221.     }
  222.     if {$isPat} {
  223.         return [list $norm $dir "" $tail]
  224.     }
  225.     }
  226.  
  227.     return [list $norm $dir $tail ""]
  228. }
  229.  
  230. # _tixJoin -- [Internal]
  231. # 
  232. #    Joins two native pathnames.
  233. #
  234. proc _tixJoin {p1 p2} {
  235.     if [tixStrEq [string index $p2 0] /] {
  236.     return [_tixNormalize $p2]
  237.     } else {
  238.     return [_tixNormalize $p1/$p2]
  239.     }
  240. }
  241.  
  242. # tixFSNormDir --
  243. #
  244. #    Normalizes an absolute path.
  245. #
  246. proc tixFSNormDir {dir} {
  247.     set dir [tixFile tilde $dir]
  248.     if ![tixStrEq [string index $dir 0] /] {
  249.     error "\"$dir\" must be an absolute pathname"
  250.     }
  251.     if ![file isdir $dir] {
  252.     error "\"$dir\" is not a directory"
  253.     }
  254.     return [_tixNormalize $dir]
  255. }
  256.  
  257. # _tixNormalize --
  258. #
  259. #    Normalizes an absolute pathname.
  260. #
  261. #     $dir must be an absolute pathname
  262. #
  263. proc _tixNormalize {path} {
  264.     tixAssert {
  265.     if ![tixStrEq [string index $path 0] /] {
  266.         error "\"$path\" must be an absolute pathname"
  267.     }
  268.     }
  269.  
  270.     # Don't be fooled: $path doesn't need to be a directory. The following
  271.     # code just makes it easy to get rid of trailing . and ..
  272.     #
  273.     set path $path/
  274.     regsub -all /+ $path / path
  275.     while 1 {
  276.     if ![regsub {/\./} $path "/" path] break
  277.     }
  278.     while 1 {
  279.     if ![regsub {/\.$} $path "" path] break
  280.     }
  281.  
  282.     while 1 {
  283.     if ![regsub {/[^/]+/\.\./} $path "/" path] break
  284.     while 1 {
  285.         if ![regsub {^/\.\./} $path "/" path] break
  286.     }
  287.     }
  288.     while 1 {
  289.     if ![regsub {^/\.\./} $path "/" path] break
  290.     }
  291.  
  292.     regsub {/$} $path "" path
  293.     if [tixStrEq $path ""] {
  294.     return /
  295.     } else {
  296.     return $path
  297.     }
  298. }
  299.  
  300. # tixFSCreateDirs
  301. #
  302. #
  303. # 
  304. proc tixFSCreateDirs {path} {
  305.     tixAssert {
  306.     error "Procedure tixFSCreateDirs not implemented on all platforms"
  307.     }
  308.     if [tixStrEq $path /] {
  309.     return 1
  310.     }
  311.     if [file exists $path] {
  312.     return 1
  313.     }
  314.     if ![tixFSCreateDirs [file dirname $path]] {
  315.     return 0
  316.     }
  317.     if [catch {exec mkdir $path}] {
  318.     return 0
  319.     }
  320.     return 1
  321. }
  322.  
  323. } else {
  324.  
  325. #-Win--------------------------------------------------------------------
  326.  
  327. # (Win) tixFSPWD --
  328. #
  329. #    Return the current directory
  330. #
  331. proc tixFSPWD {} {
  332.     set p [pwd]
  333.     regsub -all / $p \\ p
  334.     return $p
  335. }
  336. # Win
  337. #
  338. proc tixFSIsNorm {path} {
  339.  
  340.     # Drive root directory
  341.     # CYGNUS LOCAL: drive can be immediately followed by directory separator.
  342.     #
  343.     if [regexp {^[A-z]:\\?$} $path] {
  344.     return 1
  345.     }
  346.  
  347.     # If it is not a drive root directory, it must
  348.     # have a leading [drive letter:]\\[non empty string]
  349.     # CYGNUS LOCAL: A UNC path (\\host\dir) is also OK.
  350.     if ![regexp {^[A-z]:\\.} $path] {
  351.     if ![regexp {^\\\\.*\\.} $path] {
  352.         return 0
  353.     }
  354.     }
  355.  
  356.     # relative path
  357.     #
  358.     if [regexp {\\[.]$} $path] {
  359.     return 0
  360.     }
  361.     if [regexp {\\[.][.]$} $path] {
  362.     return 0
  363.     }
  364.     if [regexp {\\[.]\\} $path] {
  365.     return 0
  366.     }
  367.     if [regexp {\\[.][.]\\} $path] {
  368.     return 0
  369.     }
  370.     if [tixStrEq $path .] {
  371.     return 0
  372.     }
  373.     if [tixStrEq $path ..] {
  374.     return 0
  375.     }
  376.  
  377.     # Double slashes
  378.     # CYGNUS LOCAL: Double slashes at the front are OK.
  379.     #
  380.     if [regexp {.\\\\} $path] {
  381.     return 0
  382.     }
  383.  
  384.     # Trailing slashes
  385.     #
  386.     if [regexp {[\\]$} $path] {
  387.     return 0
  388.     }
  389.  
  390.     return 1
  391. }
  392.  
  393. # (Win) tixFSNorm --
  394. #
  395. #    Interprets the user's input and return file information about this
  396. #    input.
  397. #
  398. # Arguments:
  399. #    See documentation (docs/Files.txt)
  400. #
  401. proc tixFSNorm {context text {defFile ""} {flagsVar ""} {errorMsgVar ""}} {
  402.     tixAssert {
  403.     tixAssertVPath $context
  404.     }
  405.  
  406.     if ![tixStrEq $errorMsgVar ""] {
  407.     upvar $errorMsgVar errorMsg
  408.     }
  409.     if ![tixStrEq $flagsVar ""] {
  410.     upvar $flagsVar flags
  411.     }
  412.  
  413.     set isDir [regexp {[\\]$} $text]
  414.     set text [_tixJoin $context $text]
  415.     set path [tixFSPath $text]
  416.  
  417.     if {$isDir || [file isdir $path]} {
  418.     set vpath $text
  419.     set tail $defFile
  420.     } else {
  421.     set list [split $text \\]
  422.     set tail [lindex $list end]
  423.     set len [string length $tail]
  424.     set vpath [string range $text 0 [expr [string len $text]-$len-1]]
  425.     regsub {[\\]$} $vpath "" vpath
  426.     }
  427.  
  428.     set path [tixFSPath $vpath]
  429.  
  430.     if ![info exists flag(noPattern)] {
  431.     set isPat 0
  432.     foreach char [split $tail ""] {
  433.         if {$char == "*" || $char == "?"} {
  434.         set isPat 1
  435.         break
  436.         }
  437.     }
  438.     if {$isPat} {
  439.         return [list $path $vpath "" $tail]
  440.     }
  441.     }
  442.  
  443.     return [list $path $vpath $tail ""]
  444. }
  445.  
  446. # Win
  447. #
  448. # _tixJoin -- [internal]
  449. #
  450. #    Joins a pathname to a VPATH
  451. #
  452. proc _tixJoin {vp1 p2} {
  453.     if [tixFSIsAbsPath $p2] {
  454.     return [tixFSVPath [_tixNormalize $p2]]
  455.     } else {
  456.     return [tixFSVPath [_tixNormalize [tixFSPath $vp1]\\$p2]]
  457.     }
  458. }
  459.  
  460. # (Win) tixFSIsAbsPath
  461. #
  462. #    The Tcl "file pathtype" is buggy. E.g. C:\.\..\. is absolute, but
  463. #    "file pathtype" thinks that it isn't
  464. #
  465.  
  466. proc tixFSIsAbsPath {path} {
  467.     # CYGNUS LOCAL: Handle a UNC path (\\host\dir)
  468.     if [regexp {^\\\\.*\\.} $path] {
  469.     return 1
  470.     }
  471.     return [regexp {^[A-z]:\\} $path]
  472. }
  473.  
  474. # (Win) tixFSIsNorm_os
  475. #
  476. #    Returns true iff this pathname is normalized, in the OS native name
  477. #    format
  478. #
  479. proc tixFSIsNorm_os {path} {
  480.     if [regexp {^[A-z]:[\\]$} $path] {
  481.     return 1
  482.     }
  483.     if [regexp {^[A-z]:$} $path] {
  484.     return 0
  485.     }
  486.  
  487.     return [tixFSIsNorm $path]
  488.  
  489. }
  490.  
  491. # Win
  492. #
  493. # _tixNormalize --
  494. #
  495. #    Normalizes an absolute pathname.
  496. #
  497. #     $dir must be an absolute native pathname
  498. #
  499. proc _tixNormalize {abpath} {
  500.     tixAssert {
  501.     if ![tixFSIsAbsPath $abpath] {
  502.         error "\"$abpath\" must be an absolute pathname"
  503.     }
  504.     }
  505.  
  506.     # CYGNUS LOCAL: Handle UNC paths (\\host\dir)
  507.     if [regexp {^\\\\.*\\.} $abpath] {
  508.     set drive "\\"
  509.     regsub {^\\} $abpath "" path
  510.     } else {
  511.     if ![regexp {^[A-z]:} $abpath drive] {
  512.         tixPanic "\"$abpath\" does not contain a drive letter"
  513.     }
  514.     set drive [string toupper $drive]
  515.  
  516.     regsub {^[A-z]:} $abpath "" path
  517.     }
  518.  
  519.     # Don't be fooled: $path doesn't need to be a directory. The following
  520.     # code "set path $path\\" just makes it easy to get rid of trailing
  521.     # . and ..
  522.     #
  523.     set path $path\\
  524.     regsub -all {[\\]+} $path \\ path
  525.     while 1 {
  526.     if ![regsub {\\[.]\\} $path "\\" path] break
  527.     }
  528.     while 1 {
  529.     if ![regsub {\\[.]$} $path "" path] break
  530.     }
  531.  
  532.     while 1 {
  533.     if ![regsub {\\[^\\]+\\[.][.]\\} $path "\\" path] break
  534.     while 1 {
  535.         if ![regsub {^\\[.][.]\\} $path "\\" path] break
  536.     }
  537.     }
  538.     while 1 {
  539.     if ![regsub {^\\[.][.]\\} $path "\\" path] break
  540.     }
  541.  
  542.     regsub {[\\]+$} $path "" path
  543.     return $drive$path
  544. }
  545.  
  546. # Win
  547. #
  548. # tixFSNormDir --
  549. #
  550. #    Normalizes a directory
  551. #
  552. proc tixFSNormDir {dir} {
  553.     if ![tixFSIsAbsPath $dir] {
  554.     error "\"$dir\" must be an absolute pathname"
  555.     }
  556.     if ![file isdir $dir] {
  557.     error "\"$dir\" is not a directory"
  558.     }
  559.     return [_tixNormalize $dir]
  560. }
  561.  
  562.  
  563. proc tixPanic {message} {
  564.     error $message
  565. }
  566.  
  567. # tixFSIsValid --
  568. #
  569. #    Checks whether a native pathname contains invalid characters.
  570. #
  571. proc tixFSIsValid {path} {
  572.     return 1
  573. }
  574.  
  575. # Win
  576. #
  577. #
  578. proc tixFSIsVPath {vpath} {
  579.     global tixPriv
  580.     if $tixPriv(isWin95) {
  581.     # CYGNUS LOCAL: Accept UNC path (\\host\dir)
  582.     if [string match {xx\\xx\\\\\\*\\*} $vpath] {
  583.         return 1
  584.     }
  585.     return [string match {xx\\xx\\[A-z]:*} $vpath]
  586.     } else {
  587.     return [string match {xx\\[A-z]:*} $vpath]
  588.     }
  589. }
  590.  
  591. # Win
  592. #
  593. # tixFSVPath --
  594. #
  595. #    Converts a normalized native pathname to its VPATH
  596. #
  597. proc tixFSVPath {path} {
  598.     global tixPriv
  599.  
  600.     tixAssert {
  601.     tixAssertNorm $path
  602.     }
  603.     return $tixPriv(WinPrefix)\\$path
  604. }
  605.  
  606. # tixFSPath --
  607. #
  608. #    Converts a vpath to a native pathname
  609. proc tixFSPath {vpath} {
  610.     global tixPriv
  611.     tixAssert {
  612.     tixAssertVPath $vpath
  613.     }
  614.     if $tixPriv(isWin95) {
  615.     set path [string range $vpath 6 end]
  616.     } else {
  617.     set path [string range $vpath 3 end]
  618.     }
  619.     regsub {:$} $path :\\ path
  620.  
  621.     return $path
  622. }
  623.  
  624. # tixFSDisplayName --
  625. #
  626. #    Returns the name of a normalized path which is usually displayed by
  627. #    the OS
  628. #
  629. proc tixFSDisplayName {normpath} {
  630.     tixAssert {
  631.     tixAssertNorm $normpath
  632.     }
  633.  
  634.     if [regexp {^[A-z]:$} $normpath] {
  635.     return $normpath\\
  636.     } else {
  637.     return $normpath
  638.     }
  639. }
  640.  
  641.  
  642. tixInitFileCmpt:Win 
  643.  
  644. }
  645.